Shareware Overload Trio 2/Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO/dir26/epi601_2.zip/FILES06.EXE/ENTFACE.PAS

Pascal/Delphi Source File | 1994-08-22 | 13KB | 462 lines

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N+}    {No numeric coprocessor}
{$E+}    {Emulation on}
{$V-}    {No string type checking}

Unit EntFace;
{This unit provides routines for any Turbo Pascal (version 5+) program
 to install a vector to it's entry point at interrupt 75, and to
 access the data structures FieldList and FieldRecord.  These form
 a linked list of information about all fields in the current
 questionnaire in ENTER.  The routines FindField, GetString, GetNumber,
 PutString, and PutNumber allow access to the FieldList record for
 a named field, and transfer values from (Get) and to (Put) the
 questionnaire field in ENTER.}

  Interface

    Uses
      Crt,Dos;

    const
      EnterError   = 1;

{$I ENTTYPES.INC}

  {The following routines are available for communication between the ENTER
  program and the TSR program}

  Function FindField (Header : FieldPtr; Field : String) : FieldPtr;
  {Returns a pointer to the FieldList record for the field named in Field}

  Function InstallInterrupt (IntNo : Integer; ProcPtr : Pointer) : Integer;
  {Installs an interrupt of the IntNo given.  The interrupt vector will
   be ProcPtr, the entry point of your program.
   ProcPtr must point to a function returning an integer, with the format

    Function SomeFunc(FilePtr  : FileRecPtr;
                      GlobalVarHeader : VarPtr;
                      Header   : FieldPtr;
                      Current  : FieldPtr;
                      Data     : Integer) : Integer;
  }

  Function GetString (Header : FieldPtr; QField : String) : String;
  {Returns a string from a field in the questionnaire}

  Function GetNumber (Header : FieldPtr; QField : String) : Float;
  {Returns a number from a field in the questionnaire}

  Procedure PutString (Header : FieldPtr; QField : String; S : String);
  {Places S in the named questionnaire field}

  Procedure PutNumber (Header : FieldPtr; QField : String; R : Float);
  {Places a number, R, in the named questionnaire field}

  function FindVar(FilePtr : FileRecPtr; GlobalVarHeader : VarPtr;
                   VarName : string) : VarPtr;
  {Returns a pointer to the record for the variable named in VarName}

  Function GetStringVar (VarP : VarPtr) : String;
  {Returns a string from a variable in the questionnaire}

  Function GetNumberVar (VarP : VarPtr) : Float;
  {Returns a number from a variable in the questionnaire}

  Procedure PutStringVar (VarP : VarPtr; S : String);
  {Places S in a questionnaire variable}

  Procedure PutNumberVar (VarP : VarPtr; R : Float);
  {Places a number, R, in the named questionnaire field}

  function RecPos(RecNum : longint; FilePtr : FileRecPtr) : longint;
  {Returns the offset of record number RecNum in the file pointed to by
   FilePtr. NOTE: returns -1 if RecNum < 1 or RecNum > number of records
   in the file. The first record in the file is record #1.}

  function RecLength(FilePtr : FileRecPtr) : Integer;
  {Returns the length of a record, as it appears in the disk file, in the
   file pointed to by FilePtr.}

  Var
    EnterResult : Integer;

  Implementation

  Procedure MakeAlfa (S : String80; VAR A : Alfa);

    Var
      I : Integer;

    Begin
      FillChar(A,SizeOf(A),#32);
      I := Length(S);
      if I > SizeOf(A) then I := SizeOf(A);
      while I > 0 do
      begin
        A[I] := UpCase(S[I]);
        Dec(I);
      end;
    End (*MakeAlfa*);

  Procedure MakeString (VAR S : String80; A : Alfa);

    Var
      I : Integer;

    Begin
      S := '';
      For I := 1 to SizeOf(A) Do
      begin
        If A [I] = #32 then Exit;
        S := S + A[I];
      end;
    End (*MakeString*);

Function FindField (Header : FieldPtr; Field : String) : FieldPtr;
(*********************************************************************
 * FindField returns a pointer to the field having name = FieldName. *
 * If no such field exists in the list pointed to by header then     *
 * NIL is returned.                                                  *
 *********************************************************************)

  Var
    FPtr  : FieldPtr;
    Found : Boolean;
    Fieldname : Alfa;
    ch : Char;
    I : integer;

  Begin
    FPtr := Header;
    Found := False;
    MakeAlfa (Field, Fieldname);
      {Convert fieldname to array and pad with spaces to 10 characters}
    Repeat
      If FPtr ^.Field.Name = FieldName
      Then
        Found := True
      Else
        FPtr := FPtr ^.Next
    Until Found or (FPtr = Header);
    If Found
    Then
      FindField := FPtr
    Else
      begin
        FindField := NIL;
        GotoXY (1,25);
        Write
 ('Field ',Field,' not found. Please check TSR program and questionnaire.');
        ch := readkey;
      end;
  End (*FindField*);

Function InstallInterrupt (IntNo : Integer; ProcPtr : Pointer) : Integer;

    Type
      InterruptRecPtr  = ^ InterruptRec;
      InterruptRec     = Packed Record
                           JmpInst      : Byte;
                           OldInt       : Pointer;
                           IDString     : Array [1 .. 5] of Char;
                           OldDSValue   : Word;
                           EnterRoutine : Pointer
                         End (*InterruptRec*);

    Const
      InterruptRoutine : InterruptRec =
                           (JmpInst:      $EA;
                            OldInt:       NIL;
                            IDString:     'ENTER';
                            OldDSValue:   0;
                            EnterRoutine: NIL);

    Var
      Dummy : Pointer;

    Function GetDSValue : Word;

      Inline ($8C/$D8)   {MOV   AX,DS};

    Begin
      GetIntVec (IntNo, Dummy);
      If InterruptRecPtr (Dummy) ^.IDString = 'ENTER'
      Then
        InstallInterrupt := 1
      Else
        Begin
          InterruptRoutine.OldInt := Dummy;
          InterruptRoutine.EnterRoutine := ProcPtr;
          InterruptRoutine.OldDSValue := GetDSValue;
          SetIntVec (IntNo, @InterruptRoutine);
          InstallInterrupt := 0
        End (*Else*)
    End (*InstallInterrupt*);

Function GetString (Header : FieldPtr; QField : String) : String;
  {Returns a string from a field in the questionnaire}
 Var FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        If Missing
        Then
          GetString := ''
        Else
          GetString := FieldEntry
    End (*GetString*);

Function GetNumber (Header : FieldPtr; QField : String) : Float;
  {Returns a number from a field in the questionnaire}

 Var FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      GetNumber := 0;
      With FPtr ^ Do
        If Not Missing
        Then
          Case Field.EntryKind of
            Numeric:
              GetNumber := FieldInt;
            RealNum:
              GetNumber := FieldReal;
            Else
              EnterResult := EnterError
          End (*Case*)
    End (*GetNumber*);

Function TruncDecimals (R : Float; NumDecimals : Integer) : Float;

    Var
      Temp : Float;

    Begin
      Temp := 1;
      While (NumDecimals > 0) Do
        Begin
          Temp := Temp * 10;
          Dec (NumDecimals)
        End (*While*);
      R := Round (R * Temp);
      TruncDecimals := R / Temp
    End (*TruncDecimals*);


Procedure PutString (Header : FieldPtr; QField : String; S : String);
  {Places S in the named questionnaire field}

    Var
      I, J : Integer;
      R    : Float;
      FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        If S = ''
        Then
          Begin
            Missing := True;
            FieldEntry := ''
          End (*If*)
        Else
          Begin
            J := 0;
            Case Field.EntryKind of
              Numeric:
                Begin
                  Val (S, I, J);
                  If J = 0
                  Then
                    PutNumber (Header, QField, I)
                End (*Numeric*);
              RealNum:
                Begin
                  Val (S, R, J);
                  If J = 0
                  Then
                    PutNumber (Header, QField, R)
                End (*RealNum*);
              Else
                Begin
                  If Length (S) > Field.EntryLen
                  Then
                    S [0] := Chr (Field.EntryLen);
                  FieldEntry := S;
                  Missing := False;
                End (*Else*)
            End (*Case*);
            If J <> 0
            Then
              EnterResult := EnterError
          End (*Else*)
    End (*PutString*);

  Function MakeStringFromReal (R : Float; Width : Integer) : String;

    Var
      S : String;
      SLen : Byte Absolute S;

    Begin
      Str (R: Width*2: Width, S);
      While (S [SLen] = '0') Do
        Dec (SLen);
      If S [SLen] = '.'
      Then
        Dec (SLen);
      While (S [1] = ' ') And (SLen > 0) Do
        Delete (S, 1, 1);
      MakeStringFromReal := S
    End (*MakeStringFromReal*);


Procedure PutNumber (Header : FieldPtr; QField : String; R : Float);
  {Places a number, R, in the named questionnaire field}


    Var
      I : Integer;
   FPtr : FieldPtr;

    Begin
      FPtr := FindField (Header, QField);
      With FPtr ^ Do
        Begin
          Missing := False;
          Case Field.EntryKind of
            Numeric:
              Begin
                I := Round (R);
                Str (I: Field.EntryLen, FieldEntry);
                FieldInt := I;
              End (*Numeric*);
            RealNum:
              begin
                If Field.Decimals > 0 Then
                  Begin
                    R := TruncDecimals (R, Field.Decimals);
                    Str (R: Field.EntryLen: Field.Decimals, FieldEntry)
                  End (*If*)
                Else
                  FieldEntry := MakeStringFromReal (R, Field.EntryLen);
                FieldReal := R;
              end;
            Else
              FieldEntry := MakeStringFromReal (R, Field.EntryLen)
          End (*Case*)
        End (*With*)
    End (*PutNumber*);

Function NumberOfRecords (FilePtr : FileRecPtr) : LongInt;
Begin
  With FilePtr ^ Do
    NumberOfRecords := ((FileSize (F) - DataOffset) DIV RecSize);
End (*NumberOfRecords*);

function VarSearch(VPtr : VarPtr; Vname : String20) : VarPtr;
var
  vp : VarPtr;
begin {VarSearch}
  if VPtr = nil then VarSearch := nil
  else if VPtr^.Name = Vname then VarSearch := VPtr
  else begin
    vp := VarSearch(VPtr^.Left,Vname);
    if vp = nil then vp := VarSearch(VPtr^.Right,Vname);
    VarSearch := vp;
  end;
end; {VarSearch}

function FindVar(FilePtr : FileRecPtr; GlobalVarHeader : VarPtr;
                 VarName : string) : VarPtr;
{Returns a pointer to the record for the variable named in VarName}
  Var
    VPtr  : VarPtr;
    Vname : String20;
    ch : Char;
    I : integer;

  Begin {FindVar}
    VPtr := nil;
    Vname := VarName;
    for I := 1 to Length(Vname) do Vname[I] := UpCase(Vname[I]);
    if Vname <> '' then
    begin
      VPtr := VarSearch(FilePtr^.LocalVarHeader,Vname);
      if VPtr = nil then
          VPtr := VarSearch(GlobalVarHeader,Vname);
    end;
    if VPtr = nil then
    begin
      GotoXY (1,25);
      Write
 ('Variable ',VarName,' not found. Please check TSR program and questionnaire.');
      ch := readkey;
    end;
    FindVar := VPtr;
  End; {FindVar}

function GetStringVar (VarP : VarPtr) : string;
{Returns a string from a variable in the questionnaire}
begin
  if VarP = nil then GetStringVar := ''
  else GetStringVar := VarP^.VAlfa;
end; {GetStringVar}

function GetNumberVar (VarP : VarPtr) : Float;
{Returns a number from a variable in the questionnaire}
begin
  if VarP = nil then GetNumberVar := 0.0
  else GetNumberVar := VarP^.VFloat;
end; {GetNumberVar}

procedure PutStringVar (VarP : VarPtr; S : string);
{Places S in a questionnaire variable}
begin
  if VarP <> nil then
    with VarP^ do
  begin
    VAlfa := S;
    Missing := S = '';
  end;
end; {PutStringVar}

procedure PutNumberVar (VarP : VarPtr; R : Float);
{Places a number, R, in the named questionnaire field}
begin
  if VarP <> nil then
    with VarP^ do
  begin
    VFloat := R;
    Missing := False;
  end;
end; {PutNumberVar}

function RecPos(RecNum : longint; FilePtr : FileRecPtr) : longint;
{Returns the offset of record number RecNum in the file pointed to by
 FilePtr. NOTE: returns -1 if RecNum < 1 or RecNum > number of records
 in the file.}
begin {RecPos}
  if FilePtr = nil then RecPos := 0
  else with FilePtr^ do
    if (RecNum < 1) or (RecNum > NumberOfRecords(FilePtr)) then RecPos := -1
    else RecPos := DataOffset + (RecNum-1)*RecSize;
end; {RecPos}

function RecLength(FilePtr : FileRecPtr) : Integer;
{Returns the length of a record, as it appears in the disk file, in the
 file pointed to by FilePtr.}
begin
  if FilePtr = nil then RecLength := 0
  else RecLength := FilePtr^.RecSize;
end; {RecLength}

End.  (*ENTFACE.PAS*)